Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/filbx2/filebox.frm

Visual Basic Form | 1995-05-08 | 11.1 KB | 363 lines

VERSION 2.00
Begin Form FileBox
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Open File"
   ClientHeight    =   2775
   ClientLeft      =   3420
   ClientTop       =   945
   ClientWidth     =   5565
   Height          =   3180
   Icon            =   FILEBOX.FRX:0000
   Left            =   3360
   LinkMode        =   1  'Source
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2775
   ScaleWidth      =   5565
   Top             =   600
   Width           =   5685
   Begin DirListBox Dir1
      Height          =   280
      Left            =   3930
      TabIndex        =   9
      Top             =   1320
      Visible         =   0   'False
      Width           =   1470
   End
   Begin ListBox List1
      Height          =   1395
      Left            =   2040
      TabIndex        =   5
      Top             =   1180
      Width           =   1815
   End
   Begin DriveListBox Drive1
      Height          =   360
      Left            =   3915
      TabIndex        =   8
      Top             =   980
      Visible         =   0   'False
      Width           =   1500
   End
   Begin FileListBox File1
      Height          =   1785
      Left            =   210
      TabIndex        =   3
      Top             =   820
      Width           =   1695
   End
   Begin CommandButton Cancel
      Cancel          =   -1  'True
      Caption         =   "Cancel"
      Height          =   360
      Left            =   4335
      TabIndex        =   7
      Top             =   560
      Width           =   1095
   End
   Begin CommandButton OK
      Caption         =   "OK"
      Default         =   -1  'True
      Height          =   360
      Left            =   4335
      TabIndex        =   6
      Top             =   120
      Width           =   1095
   End
   Begin TextBox Text1
      Height          =   300
      Left            =   1320
      TabIndex        =   1
      Text            =   "*.*"
      Top             =   140
      Width           =   2760
   End
   Begin Label Label4
      Caption         =   "&Directories:"
      Height          =   260
      Left            =   2070
      TabIndex        =   4
      Top             =   900
      Width           =   1530
   End
   Begin Label Label1
      Height          =   260
      Left            =   1950
      TabIndex        =   10
      Top             =   500
      Width           =   2160
   End
   Begin Label Label3
      Caption         =   "&Files:"
      Height          =   240
      Left            =   255
      TabIndex        =   2
      Top             =   480
      Width           =   825
   End
   Begin Label Label2
      Caption         =   "File &Name:"
      Height          =   260
      Left            =   285
      TabIndex        =   0
      Top             =   140
      Width           =   975
   End
'                               Filebox/Filebox2 by
'                                   Thomas Kiehl
'                                   P.O. Box 693
'                         Indian Rocks Beach, FL  34635
'                                  CIS: 73215,427
'This File Open Dialog Box Form and associated modules and forms are hereby released
'to the public domain to be used as seen fit by those who may use it, provided that
'such user understands that the author expresses no warranty, promise or claim of
'liability for its use, consequental use and/or damages to hardware, software or data.
DefInt A-Z
' FILEBOX declarations and constants
Dim LastChanged
Dim LastPattern As String
Dim CurrDir As String
Const ASCII_ENTER = 13
Const WM_USER = &H400
Const LB_RESETCONTENT = WM_USER + 5
Const TEXT_CHANGED = 0
Const FILE_CHANGED = 1
Const DIR_CHANGED = 2
Declare Function SendMessage% Lib "user" (ByVal hWnd%, ByVal wMsg%, ByVal wParam%, ByVal lParam&)
Declare Function GetFocus% Lib "user" ()
Declare Function PutFocus% Lib "user" Alias "SetFocus" (ByVal hWnd%)
Sub Cancel_Click ()
    Unload Filebox
End Sub
Sub ClearListBox (Ctrl As Control)
  If Ctrl.Visible Then
    hWndOld = GetFocus()
    list1.SetFocus
    x = SendMessage(GetFocus(), LB_RESETCONTENT, 0, 0)
    x = PutFocus(hWndOld)
  End If
End Sub
Sub Command1_Click ()
    Unload Filebox
End Sub
Sub Dir1_change ()
  ChDir (Dir1.path)
  file1.path = Dir1.path
  Label1.Caption = file1.path
  List1_Update
End Sub
Sub Drive1_Change ()
 On Error Resume Next
 Dir1.path = CurDir$(drive1.drive)
 If Err Then                'chances of an error getting here are slim
  MsgBox Error$
  drive1.drive = Dir1.path
 End If
 List1_Update
End Sub
Sub File1_Click ()
    LastChanged = FILE_CHANGED
    If file1.Listindex >= 0 Then    'zero based filename index
        text1.text = file1.filename
    End If
    If text1.text = "" Then
        OK.enabled = False
    Else
        OK.enabled = True
    End If
End Sub
Sub File1_DblClick ()
    LastChanged = FILE_CHANGED
    OK_Click
End Sub
Sub File1_KeyPress (KeyAscii As Integer)
    LastChanged = FILE_CHANGED
    If text1.text = "" Then
        OK.enabled = False
    Else
        OK.enabled = True
    End If
End Sub
Sub Form_Load ()
  Filebox.top = 1240
  Filebox.left = 2592
  Filebox.height = 3240
  Filebox.width = 5640
  LastPattern = "*.*"
  file1.Pattern = LastPattern
  List1_Update
  Label1.Caption = file1.path
  text1.selstart = 0
  text1.sellength = Len(text1.text)
  OK.enabled = True
  LastChanged = TEXT_CHANGED
End Sub
Sub List1_Click ()
  Dim startpos As Integer
  LastChanged = DIR_CHANGED
  OK.enabled = True
  If list1.text = "[..]" Then            ' Change to the parent directory
    text1.text = "..\" + file1.Pattern
  Else
    If Left$(list1.text, 2) = "[-" Then   ' This is a drive spec
        text1.text = Mid$(list1.text, 3, 1) + ":" + file1.Pattern
    Else ' This is a subdirectory of the current directory
        startpos = Len(CurrDir) + 2
        If list1.List(0) = "[..]" Then
            text1.text = Mid$(Dir1.List((list1.Listindex) - 1), startpos) + "\" + file1.Pattern
        Else
            text1.text = Mid$(Dir1.List(list1.Listindex), startpos - 1) + "\" + file1.Pattern
        End If
    End If
  End If
End Sub
Sub List1_Dblclick ()
  LastChanged = DIR_CHANGED
  If list1.text = "[..]" Then                     'the parent directory
    Dir1.path = Dir1.List(-2)
    Dir1_change
  Else
    If Left$(list1.text, 2) = "[-" Then           'this is a drive spec
      On Error GoTo list1_error
      Dummy$ = Dir$(Mid$(list1.text, 3, 1) + ":") 'error if door is open
                                                  'error has been trapped out
      drive1.drive = Mid$(list1.text, 3, 1) + ":" 'error if door is open (we did check it)
    Else                                          'sub directory
      If list1.List(0) = "[..]" Then              'we are not at root dir
        Dir1.path = Dir1.List((list1.Listindex) - 1)
      Else                                         'oh yes we are
        Dir1.path = Dir1.List(list1.Listindex)
      End If
      Dir1_change                                  'do the event
    End If
  End If
Exit Sub
list1_error:                                        'uh oh!
    Beep
    If Err = FILE_NOT_FOUND Then
        Button = MB_OK + MB_ICONEXCLAMATION
    Else
        Button = MB_ICONQUESTION + MB_RETRYCANCEL
    End If
    Button = MsgBox("ERROR: " + Error$(Err) + Str$(Err), Button, "FILE OPEN")
    If Button = IDRETRY Then
      Resume
    End If
    On Error GoTo 0
    Exit Sub
End Sub
Sub List1_Update ()
  ClearListBox list1
  CurrDir = Dir1.path
  If Len(CurrDir) > 3 Then
    list1.AddItem "[..]"
    DirPos = Len(CurrDir) + 2
  Else
    DirPos = 4
  End If
  For Count = 0 To Dir1.listcount - 1
    list1.AddItem "[" + Mid$(Dir1.List(Count), DirPos) + "]"
  Next Count
  For Count = 0 To drive1.listcount - 1
    list1.AddItem "[-" + Left$(drive1.List(Count), 1) + "-]"
  Next Count
  update_filespec
End Sub
Sub OK_Click ()
  Dim temp As String
  If text1.text = "" Then     'we shouldn't be here in the first place
    Exit Sub
  End If
  If LastChanged <> FILE_CHANGED Then
        Is_Valid = Valid_FileSpec()   'try and open filespec
  Else
      WorkFile = file1.path
      If Right$(WorkFile, 1) <> "\" Then
        WorkFile = WorkFile + "\"
      End If
      WorkFile = WorkFile + file1.filename
      Unload Filebox
  End If
Exit Sub
End                 'left over from development
Drive_Error:
    MsgBox Error$(Err)
    Exit Sub
dir_change_error:
    Beep
    If Err = FILE_NOT_FOUND Then
        Button = MB_OK + MB_ICONEXCLAMATION
    Else
        Button = MB_ICONQUESTION + MB_RETRYCANCEL
    End If
    Button = MsgBox("ERROR: " + Error$(Err) + Str$(Err), Button, "FILE OPEN")
    If Button = IDRETRY Then
      Resume
    End If
    On Error GoTo 0
    Exit Sub
End Sub
Sub Text1_Change ()
    If LastChanged = TEXT_CHANGED Then
        If text1.text = "" Then
          OK.enabled = False
        Else
          OK.enabled = True
        End If
    End If
End Sub
Sub Text1_KeyDown (keycode As Integer, Shift As Integer)
  LastChanged = TEXT_CHANGED
End Sub
Sub update_filespec ()
Dim SelPath As String, CurPath As String, slash As String 'slash is null at this point
  CurPath = Label1.Caption
  SelPath = list1.List(list1.Listindex)
  Select Case list1.Listindex
    Case Is >= 0         'a subdirectory
      I = Right$(CurPath, 1) <> "\"
      file1.text = Right$(SelPath, Len(SelPath) - Len(CurPath) + I) + "\" + file1.Pattern

    Case -1             'the current directory
      text1.text = file1.Pattern

    Case Is < -1        'the parent directory
      SelPath = Right$(SelPath, Len(SelPath) - 2)
      If Len(SelPath) > 1 Then slash = "\"
      text1.text = SelPath + slash + file1.Pattern
  End Select
End Sub
Function Valid_FileSpec ()
  Dim temp As String
  On Error GoTo ErrorInSpec
  Valid_FileSpec = True
  temp = Dir$(text1.text)
  file1.filename = text1.text
  ChDir file1.path                       'gets here if good path only
  drive1.drive = Left$(file1.path, 2)
  Dir1.path = file1.path
  Valid_FileSpec = False
Quit_Function:
  On Error GoTo 0
Exit Function
ErrorInSpec:
  If (Err <> FILE_NOT_FOUND) Then
    Beep
    Button = MB_ICONQUESTION + MB_RETRYCANCEL
    Button = MsgBox("ERROR: " + Error$(Err) + Str$(Err), Button, "FILE OPEN")
    If Button = IDRETRY Then
      Resume
    End If
  Else
    If Err = FILE_NOT_FOUND Then            'no other error
                                            'but is was NOT a wildcard
      temp = Right$(text1.text, 1)
      file1.filename = Left$(text1.text, Len(text1.text) - 1) + "*"
      text1.text = Left$(file1.Pattern, Len(file1.Pattern) - 1) + temp
    End If
    Valid_FileSpec = False
  End If
  Resume Quit_Function
End Function